home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlinit.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  8.0 KB  |  262 lines
  1. /* xlinit.c - xlisp initialization module */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL true,s_dot,s_unbound;
  10. extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
  11. extern LVAL s_lambda,s_macro;
  12. extern LVAL s_stdin,s_stdout,s_stderr,s_debugio,s_traceout;
  13. extern LVAL s_evalhook,s_applyhook,s_tracelist;
  14. extern LVAL s_tracenable,s_tlimit,s_breakenable;
  15. extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get,s_eql;
  16. extern LVAL s_svalue,s_sfunction,s_splist;
  17. extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
  18. extern LVAL k_sescape,k_mescape;
  19. extern LVAL s_ifmt,s_ffmt,s_printcase;
  20. extern LVAL s_printlevel,s_printlength,s_dosinput;        /* TAA mod */
  21. extern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
  22. extern LVAL k_test,k_tnot;
  23. extern LVAL k_direction,k_input,k_output;
  24. #ifdef BETTERIO
  25. extern LVAL k_io, k_elementtype;
  26. #endif
  27. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  28. extern LVAL k_verbose,k_print,k_count,k_key,k_upcase,k_downcase;
  29. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  30. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  31. extern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object;
  32. extern LVAL a_vector,a_closure,a_char,a_ustream;
  33. extern LVAL s_gcflag,s_gchook;
  34. #ifdef COMMONLISP
  35. extern LVAL s_elt;
  36. #endif
  37. extern FUNDEF funtab[];
  38.  
  39. /* Forward declarations */
  40. #ifdef ANSI
  41. FORWARD VOID initwks(void);
  42. #else
  43. FORWARD VOID initwks();
  44. #endif
  45.  
  46. /* xlinit - xlisp initialization routine */
  47. int xlinit(nores)        /* TAA Mod -- return true if load of init.lsp needed */
  48.         int nores;
  49. {
  50.     /* initialize xlisp (must be in this order) */
  51.     xlminit();    /* initialize xldmem.c */
  52.     xldinit();    /* initialize xldbug.c */
  53.  
  54.     /* finish initializing */
  55. #ifdef SAVERESTORE
  56.     if (nores || !xlirestore("xlisp.wks")) {
  57.         initwks();
  58.         return TRUE;
  59.     }
  60.     return FALSE;
  61. #else
  62.     initwks();
  63.     return TRUE;
  64. #endif
  65. }
  66.  
  67. /* initwks - build an initial workspace */
  68. LOCAL VOID initwks()
  69. {
  70.     FUNDEF *p;
  71.     int i;
  72.     
  73.     xlsinit();    /* initialize xlsym.c */
  74.     xlsymbols();/* enter all symbols used by the interpreter */
  75.     xlrinit();    /* initialize xlread.c */
  76.     xloinit();    /* initialize xlobj.c */
  77.  
  78.     /* setup defaults */
  79.     setvalue(s_evalhook,NIL);            /* no evalhook function */
  80.     setvalue(s_applyhook,NIL);            /* no applyhook function */
  81.     setvalue(s_tracelist,NIL);            /* no functions being traced */
  82.     setvalue(s_tracenable,NIL);            /* traceback disabled */
  83.     setvalue(s_tlimit,NIL);                /* trace limit infinite */
  84.     setvalue(s_breakenable,NIL);        /* don't enter break loop on errors */
  85.     setvalue(s_gcflag,NIL);                /* don't show gc information */
  86.     setvalue(s_gchook,NIL);                /* no gc hook active */
  87.     setvalue(s_ifmt,cvstring(IFMT));    /* integer print format */
  88.     setvalue(s_ffmt,cvstring("%g"));    /* float print format */
  89.     setvalue(s_printcase,k_upcase);        /* upper case output of symbols */
  90.     setvalue(s_printlevel,NIL);            /* printing depth is infinite */
  91.     setvalue(s_printlength,NIL);        /* printing length is infinite */
  92.     setvalue(s_dosinput,NIL);
  93.  
  94.     /* install the built-in functions and special forms */
  95.     for (i = 0, p = funtab; (p->fd_subr) != (LVAL(*)())0; ++i, ++p)
  96.         if (p->fd_name)
  97.             xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
  98.  
  99.     /* add some synonyms */
  100.     setfunction(xlenter("NOT"),getfunction(xlenter("NULL")));
  101.     setfunction(xlenter("FIRST"),getfunction(xlenter("CAR")));
  102.     setfunction(xlenter("SECOND"),getfunction(xlenter("CADR")));
  103.     setfunction(xlenter("THIRD"),getfunction(xlenter("CADDR")));
  104.     setfunction(xlenter("FOURTH"),getfunction(xlenter("CADDDR")));
  105.     setfunction(xlenter("REST"),getfunction(xlenter("CDR")));
  106. }
  107.  
  108. /* xlsymbols - enter all of the symbols used by the interpreter */
  109. VOID xlsymbols()
  110. {
  111.     LVAL sym;
  112.  
  113.     /* enter the unbound variable indicator (must be first) */
  114.     s_unbound = xlenter("*UNBOUND*");
  115.     setvalue(s_unbound,s_unbound);
  116.  
  117.     /* enter the 't' symbol */
  118.     true = xlenter("T");
  119.     setvalue(true,true);
  120.  
  121.     /* enter some important symbols */
  122.     s_dot        = xlenter(".");
  123.     s_quote        = xlenter("QUOTE");
  124.     s_function    = xlenter("FUNCTION");
  125.     s_bquote    = xlenter("BACKQUOTE");
  126.     s_comma        = xlenter("COMMA");
  127.     s_comat        = xlenter("COMMA-AT");
  128.     s_lambda    = xlenter("LAMBDA");
  129.     s_macro        = xlenter("MACRO");
  130.     s_eql        = xlenter("EQL");
  131.     s_ifmt        = xlenter("*INTEGER-FORMAT*");
  132.     s_ffmt        = xlenter("*FLOAT-FORMAT*");
  133.  
  134.     /* symbols set by the read-eval-print loop */
  135.     s_1plus        = xlenter("+");
  136.     s_2plus        = xlenter("++");
  137.     s_3plus        = xlenter("+++");
  138.     s_1star        = xlenter("*");
  139.     s_2star        = xlenter("**");
  140.     s_3star        = xlenter("***");
  141.     s_minus        = xlenter("-");
  142.  
  143.     /* enter setf place specifiers */
  144.     s_setf        = xlenter("*SETF*");
  145.     s_car        = xlenter("CAR");
  146.     s_cdr        = xlenter("CDR");
  147.     s_nth        = xlenter("NTH");
  148.     s_aref        = xlenter("AREF");
  149. #ifdef COMMONLISP
  150.     s_elt    = xlenter("ELT");
  151. #endif
  152.     s_get        = xlenter("GET");
  153.     s_svalue    = xlenter("SYMBOL-VALUE");
  154.     s_sfunction = xlenter("SYMBOL-FUNCTION");
  155.     s_splist    = xlenter("SYMBOL-PLIST");
  156.  
  157.     /* enter the readtable variable and keywords */
  158.     s_rtable    = xlenter("*READTABLE*");
  159.     k_wspace    = xlenter(":WHITE-SPACE");
  160.     k_const        = xlenter(":CONSTITUENT");
  161.     k_nmacro    = xlenter(":NMACRO");
  162.     k_tmacro    = xlenter(":TMACRO");
  163.     k_sescape    = xlenter(":SESCAPE");
  164.     k_mescape    = xlenter(":MESCAPE");
  165.  
  166.     /* enter parameter list keywords */
  167.     k_test        = xlenter(":TEST");
  168.     k_tnot        = xlenter(":TEST-NOT");
  169.  
  170.     /* "open" keywords */
  171.     k_direction = xlenter(":DIRECTION");
  172.     k_input        = xlenter(":INPUT");
  173.     k_output    = xlenter(":OUTPUT");
  174. #ifdef BETTERIO
  175.     k_io        = xlenter(":IO");
  176.     k_elementtype = xlenter(":ELEMENT-TYPE");
  177. #endif
  178.  
  179.     /* enter *print-case* symbol and keywords */
  180.     s_printcase = xlenter("*PRINT-CASE*");
  181.     k_upcase    = xlenter(":UPCASE");
  182.     k_downcase    = xlenter(":DOWNCASE");
  183.  
  184.     /* more printining symbols */
  185.     s_printlevel= xlenter("*PRINT-LEVEL*");
  186.     s_printlength = xlenter("*PRINT-LENGTH*");
  187.     s_dosinput    = xlenter("*DOS-INPUT*");
  188.         
  189.     /* other keywords */
  190.     k_start        = xlenter(":START");
  191.     k_end        = xlenter(":END");
  192.     k_1start    = xlenter(":START1");
  193.     k_1end        = xlenter(":END1");
  194.     k_2start    = xlenter(":START2");
  195.     k_2end        = xlenter(":END2");
  196.     k_verbose    = xlenter(":VERBOSE");
  197.     k_print        = xlenter(":PRINT");
  198.     k_count        = xlenter(":COUNT");
  199.     k_key        = xlenter(":KEY");
  200.  
  201.     /* enter lambda list keywords */
  202.     lk_optional = xlenter("&OPTIONAL");
  203.     lk_rest        = xlenter("&REST");
  204.     lk_key        = xlenter("&KEY");
  205.     lk_aux        = xlenter("&AUX");
  206.     lk_allow_other_keys = xlenter("&ALLOW-OTHER-KEYS");
  207.  
  208.     /* enter *standard-input*, *standard-output* and *error-output* */
  209.     s_stdin = xlenter("*STANDARD-INPUT*");
  210.     setvalue(s_stdin,cvfile(stdin));
  211.     s_stdout = xlenter("*STANDARD-OUTPUT*");
  212.     setvalue(s_stdout,cvfile(stdout));
  213.     s_stderr = xlenter("*ERROR-OUTPUT*");
  214.     setvalue(s_stderr,cvfile(stderr));
  215.  
  216.     /* enter *debug-io* and *trace-output* */
  217.     s_debugio = xlenter("*DEBUG-IO*");
  218.     setvalue(s_debugio,getvalue(s_stderr));
  219.     s_traceout = xlenter("*TRACE-OUTPUT*");
  220.     setvalue(s_traceout,getvalue(s_stderr));
  221.  
  222.     /* enter the eval and apply hook variables */
  223.     s_evalhook = xlenter("*EVALHOOK*");
  224.     s_applyhook = xlenter("*APPLYHOOK*");
  225.  
  226.     /* enter the symbol pointing to the list of functions being traced */
  227.     s_tracelist = xlenter("*TRACELIST*");
  228.  
  229.     /* enter the error traceback and the error break enable flags */
  230.     s_tracenable = xlenter("*TRACENABLE*");
  231.     s_tlimit = xlenter("*TRACELIMIT*");
  232.     s_breakenable = xlenter("*BREAKENABLE*");
  233.  
  234.     /* enter a symbol to control printing of garbage collection messages */
  235.     s_gcflag = xlenter("*GC-FLAG*");
  236.     s_gchook = xlenter("*GC-HOOK*");
  237.  
  238.     /* enter a copyright notice into the oblist */
  239.     sym = xlenter("**Copyright-1988-by-David-Betz**");
  240.     setvalue(sym,true);
  241.  
  242.     /* enter type names */
  243.     a_subr        = xlenter("SUBR");
  244.     a_fsubr        = xlenter("FSUBR");
  245.     a_cons        = xlenter("CONS");
  246.     a_symbol    = xlenter("SYMBOL");
  247.     a_fixnum    = xlenter("FIXNUM");
  248.     a_flonum    = xlenter("FLONUM");
  249.     a_string    = xlenter("STRING");
  250.     a_object    = xlenter("OBJECT");
  251.     a_stream    = xlenter("FILE-STREAM");
  252.     a_vector    = xlenter("ARRAY");
  253.     a_closure    = xlenter("CLOSURE");
  254.     a_char        = xlenter("CHARACTER");
  255.     a_ustream    = xlenter("UNNAMED-STREAM");
  256.  
  257.     /* add the object-oriented programming symbols and os specific stuff */
  258.     obsymbols();        /* object-oriented programming symbols */
  259.     ossymbols();        /* os specific symbols */
  260. }
  261.  
  262.